home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / 1.6.0 / ice-9 / calling.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  11.8 KB  |  352 lines
  1. ;;;; calling.scm --- Calling Conventions
  2. ;;;;
  3. ;;;;     Copyright (C) 1995, 1996, 1997, 2000, 2001 Free Software Foundation, Inc.
  4. ;;;; 
  5. ;;;; This program is free software; you can redistribute it and/or modify
  6. ;;;; it under the terms of the GNU General Public License as published by
  7. ;;;; the Free Software Foundation; either version 2, or (at your option)
  8. ;;;; any later version.
  9. ;;;; 
  10. ;;;; This program is distributed in the hope that it will be useful,
  11. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13. ;;;; GNU General Public License for more details.
  14. ;;;; 
  15. ;;;; You should have received a copy of the GNU General Public License
  16. ;;;; along with this software; see the file COPYING.  If not, write to
  17. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18. ;;;; Boston, MA 02111-1307 USA
  19. ;;;;
  20. ;;;; As a special exception, the Free Software Foundation gives permission
  21. ;;;; for additional uses of the text contained in its release of GUILE.
  22. ;;;;
  23. ;;;; The exception is that, if you link the GUILE library with other files
  24. ;;;; to produce an executable, this does not by itself cause the
  25. ;;;; resulting executable to be covered by the GNU General Public License.
  26. ;;;; Your use of that executable is in no way restricted on account of
  27. ;;;; linking the GUILE library code into it.
  28. ;;;;
  29. ;;;; This exception does not however invalidate any other reasons why
  30. ;;;; the executable file might be covered by the GNU General Public License.
  31. ;;;;
  32. ;;;; This exception applies only to the code released by the
  33. ;;;; Free Software Foundation under the name GUILE.  If you copy
  34. ;;;; code from other Free Software Foundation releases into a copy of
  35. ;;;; GUILE, as the General Public License permits, the exception does
  36. ;;;; not apply to the code that you add in this way.  To avoid misleading
  37. ;;;; anyone as to the status of such modified files, you must delete
  38. ;;;; this exception notice from them.
  39. ;;;;
  40. ;;;; If you write modifications of your own for GUILE, it is your choice
  41. ;;;; whether to permit this exception to apply to your modifications.
  42. ;;;; If you do not wish that, delete this exception notice.
  43. ;;;; 
  44.  
  45. (define-module (ice-9 calling)
  46.   :export-syntax (with-excursion-function
  47.           with-getter-and-setter
  48.           with-getter
  49.           with-delegating-getter-and-setter
  50.           with-excursion-getter-and-setter
  51.           with-configuration-getter-and-setter
  52.           with-delegating-configuration-getter-and-setter
  53.           let-with-configuration-getter-and-setter))
  54.  
  55. ;;;;
  56. ;;;
  57. ;;; This file contains a number of macros that support 
  58. ;;; common calling conventions.
  59.  
  60. ;;;
  61. ;;; with-excursion-function <vars> proc
  62. ;;;  <vars> is an unevaluated list of names that are bound in the caller.
  63. ;;;  proc is a procedure, called:
  64. ;;;         (proc excursion)
  65. ;;;
  66. ;;;  excursion is a procedure isolates all changes to <vars>
  67. ;;;  in the dynamic scope of the call to proc.  In other words,
  68. ;;;  the values of <vars> are saved when proc is entered, and when
  69. ;;;  proc returns, those values are restored.   Values are also restored
  70. ;;;  entering and leaving the call to proc non-locally, such as using
  71. ;;;  call-with-current-continuation, error, or throw.
  72. ;;;
  73. (defmacro with-excursion-function (vars proc)
  74.   `(,proc ,(excursion-function-syntax vars)))
  75.  
  76.  
  77.  
  78. ;;; with-getter-and-setter <vars> proc
  79. ;;;  <vars> is an unevaluated list of names that are bound in the caller.
  80. ;;;  proc is a procedure, called:
  81. ;;;    (proc getter setter)
  82. ;;; 
  83. ;;;  getter and setter are procedures used to access
  84. ;;;  or modify <vars>.
  85. ;;; 
  86. ;;;  setter, called with keywords arguments, modifies the named
  87. ;;;  values.   If "foo" and "bar" are among <vars>, then:
  88. ;;; 
  89. ;;;    (setter :foo 1 :bar 2)
  90. ;;;    == (set! foo 1 bar 2)
  91. ;;; 
  92. ;;;  getter, called with just keywords, returns
  93. ;;;  a list of the corresponding values.  For example,
  94. ;;;  if "foo" and "bar" are among the <vars>, then
  95. ;;; 
  96. ;;;    (getter :foo :bar)
  97. ;;;    => (<value-of-foo> <value-of-bar>)
  98. ;;; 
  99. ;;;  getter, called with no arguments, returns a list of all accepted 
  100. ;;;  keywords and the corresponding values.  If "foo" and "bar" are
  101. ;;;  the *only* <vars>, then:
  102. ;;; 
  103. ;;;    (getter)
  104. ;;;    => (:foo <value-of-bar> :bar <value-of-foo>)
  105. ;;; 
  106. ;;;  The unusual calling sequence of a getter supports too handy
  107. ;;;  idioms:
  108. ;;; 
  109. ;;;    (apply setter (getter))        ;; save and restore
  110. ;;; 
  111. ;;;    (apply-to-args (getter :foo :bar)        ;; fetch and bind
  112. ;;;            (lambda (foo bar) ....))
  113. ;;; 
  114. ;;;     ;; [ "apply-to-args" is just like two-argument "apply" except that it 
  115. ;;;    ;;   takes its arguments in a different order.
  116. ;;; 
  117. ;;;
  118. (defmacro with-getter-and-setter (vars proc)
  119.   `(,proc ,@ (getter-and-setter-syntax vars)))
  120.  
  121. ;;; with-getter vars proc
  122. ;;;   A short-hand for a call to with-getter-and-setter.
  123. ;;;   The procedure is called:
  124. ;;;        (proc getter)
  125. ;;;
  126. (defmacro with-getter (vars proc)
  127.   `(,proc ,(car (getter-and-setter-syntax vars))))
  128.  
  129.  
  130. ;;; with-delegating-getter-and-setter <vars> get-delegate set-delegate proc
  131. ;;;   Compose getters and setters.
  132. ;;; 
  133. ;;;   <vars> is an unevaluated list of names that are bound in the caller.
  134. ;;;   
  135. ;;;   get-delegate is called by the new getter to extend the set of 
  136. ;;;    gettable variables beyond just <vars>
  137. ;;;   set-delegate is called by the new setter to extend the set of 
  138. ;;;    gettable variables beyond just <vars>
  139. ;;;
  140. ;;;   proc is a procedure that is called
  141. ;;;        (proc getter setter)
  142. ;;;
  143. (defmacro with-delegating-getter-and-setter (vars get-delegate set-delegate proc)
  144.   `(,proc ,@ (delegating-getter-and-setter-syntax vars get-delegate set-delegate)))
  145.  
  146.  
  147. ;;; with-excursion-getter-and-setter <vars> proc
  148. ;;;   <vars> is an unevaluated list of names that are bound in the caller.
  149. ;;;   proc is called:
  150. ;;;
  151. ;;;        (proc excursion getter setter)
  152. ;;;
  153. ;;;   See also:
  154. ;;;    with-getter-and-setter
  155. ;;;    with-excursion-function
  156. ;;;
  157. (defmacro with-excursion-getter-and-setter (vars proc)
  158.   `(,proc  ,(excursion-function-syntax vars)
  159.       ,@ (getter-and-setter-syntax vars)))
  160.  
  161.  
  162. (define (excursion-function-syntax vars)
  163.   (let ((saved-value-names (map gensym vars))
  164.     (tmp-var-name (gensym "temp"))
  165.     (swap-fn-name (gensym "swap"))
  166.     (thunk-name (gensym "thunk")))
  167.     `(lambda (,thunk-name)
  168.        (letrec ((,tmp-var-name #f)
  169.         (,swap-fn-name
  170.          (lambda () ,@ (map (lambda (n sn) 
  171.                       `(begin (set! ,tmp-var-name ,n)
  172.                           (set! ,n ,sn)
  173.                           (set! ,sn ,tmp-var-name)))
  174.                     vars saved-value-names)))
  175.         ,@ (map (lambda (sn n) `(,sn ,n)) saved-value-names vars))
  176.      (dynamic-wind
  177.       ,swap-fn-name
  178.       ,thunk-name
  179.       ,swap-fn-name)))))
  180.  
  181.  
  182. (define (getter-and-setter-syntax vars)
  183.   (let ((args-name (gensym "args"))
  184.     (an-arg-name (gensym "an-arg"))
  185.     (new-val-name (gensym "new-value"))
  186.     (loop-name (gensym "loop"))
  187.     (kws (map symbol->keyword vars)))
  188.     (list `(lambda ,args-name
  189.          (let ,loop-name ((,args-name ,args-name))
  190.           (if (null? ,args-name)
  191.               ,(if (null? kws)
  192.                ''()
  193.                `(let ((all-vals (,loop-name ',kws)))
  194.                   (let ,loop-name ((vals all-vals)
  195.                            (kws ',kws))
  196.                    (if (null? vals)
  197.                        '()
  198.                        `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
  199.               (map (lambda (,an-arg-name)
  200.                  (case ,an-arg-name
  201.                    ,@ (append
  202.                    (map (lambda (kw v) `((,kw) ,v)) kws vars)
  203.                    `((else (throw 'bad-get-option ,an-arg-name))))))
  204.                ,args-name))))
  205.  
  206.       `(lambda ,args-name
  207.          (let ,loop-name ((,args-name ,args-name))
  208.           (or (null? ,args-name)
  209.               (null? (cdr ,args-name))
  210.               (let ((,an-arg-name (car ,args-name))
  211.                 (,new-val-name (cadr ,args-name)))
  212.             (case ,an-arg-name
  213.               ,@ (append
  214.                   (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
  215.                   `((else (throw 'bad-set-option ,an-arg-name)))))
  216.             (,loop-name (cddr ,args-name)))))))))
  217.  
  218. (define (delegating-getter-and-setter-syntax  vars get-delegate set-delegate)
  219.   (let ((args-name (gensym "args"))
  220.     (an-arg-name (gensym "an-arg"))
  221.     (new-val-name (gensym "new-value"))
  222.     (loop-name (gensym "loop"))
  223.     (kws (map symbol->keyword vars)))
  224.     (list `(lambda ,args-name
  225.          (let ,loop-name ((,args-name ,args-name))
  226.           (if (null? ,args-name)
  227.               (append!
  228.                ,(if (null? kws)
  229.                 ''()
  230.                 `(let ((all-vals (,loop-name ',kws)))
  231.                    (let ,loop-name ((vals all-vals)
  232.                         (kws ',kws))
  233.                     (if (null? vals)
  234.                     '()
  235.                     `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
  236.                (,get-delegate))
  237.               (map (lambda (,an-arg-name)
  238.                  (case ,an-arg-name
  239.                    ,@ (append
  240.                    (map (lambda (kw v) `((,kw) ,v)) kws vars)
  241.                    `((else (car (,get-delegate ,an-arg-name)))))))
  242.                ,args-name))))
  243.  
  244.       `(lambda ,args-name
  245.          (let ,loop-name ((,args-name ,args-name))
  246.           (or (null? ,args-name)
  247.               (null? (cdr ,args-name))
  248.               (let ((,an-arg-name (car ,args-name))
  249.                 (,new-val-name (cadr ,args-name)))
  250.             (case ,an-arg-name
  251.               ,@ (append
  252.                   (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
  253.                   `((else  (,set-delegate ,an-arg-name ,new-val-name)))))
  254.             (,loop-name (cddr ,args-name)))))))))
  255.  
  256.  
  257.  
  258.  
  259. ;;; with-configuration-getter-and-setter <vars-etc> proc
  260. ;;;
  261. ;;;  Create a getter and setter that can trigger arbitrary computation.
  262. ;;;
  263. ;;;  <vars-etc> is a list of variable specifiers, explained below.
  264. ;;;  proc is called:
  265. ;;;
  266. ;;;        (proc getter setter)
  267. ;;;
  268. ;;;   Each element of the <vars-etc> list is of the form:
  269. ;;;
  270. ;;;    (<var> getter-hook setter-hook)
  271. ;;;
  272. ;;;   Both hook elements are evaluated; the variable name is not.
  273. ;;;   Either hook may be #f or procedure.
  274. ;;;
  275. ;;;   A getter hook is a thunk that returns a value for the corresponding
  276. ;;;   variable.   If omitted (#f is passed), the binding of <var> is
  277. ;;;   returned.
  278. ;;;
  279. ;;;   A setter hook is a procedure of one argument that accepts a new value
  280. ;;;   for the corresponding variable.  If omitted, the binding of <var>
  281. ;;;   is simply set using set!.
  282. ;;;
  283. (defmacro with-configuration-getter-and-setter (vars-etc proc)
  284.   `((lambda (simpler-get simpler-set body-proc)
  285.       (with-delegating-getter-and-setter ()
  286.     simpler-get simpler-set body-proc))
  287.  
  288.     (lambda (kw)
  289.       (case kw
  290.     ,@(map (lambda (v) `((,(symbol->keyword (car v)))
  291.                  ,(cond
  292.                    ((cadr v)    => list)
  293.                    (else        `(list ,(car v))))))
  294.            vars-etc)))
  295.  
  296.     (lambda (kw new-val)
  297.       (case kw
  298.     ,@(map (lambda (v) `((,(symbol->keyword (car v)))
  299.                  ,(cond
  300.                    ((caddr v)    => (lambda (proc) `(,proc new-val)))
  301.                    (else        `(set! ,(car v) new-val)))))
  302.            vars-etc)))
  303.  
  304.        ,proc))
  305.  
  306. (defmacro with-delegating-configuration-getter-and-setter (vars-etc delegate-get delegate-set proc)
  307.   `((lambda (simpler-get simpler-set body-proc)
  308.       (with-delegating-getter-and-setter ()
  309.     simpler-get simpler-set body-proc))
  310.  
  311.     (lambda (kw)
  312.       (case kw
  313.     ,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
  314.                       ,(cond
  315.                     ((cadr v)    => list)
  316.                     (else        `(list ,(car v))))))
  317.             vars-etc)
  318.            `((else (,delegate-get kw))))))
  319.  
  320.     (lambda (kw new-val)
  321.       (case kw
  322.     ,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
  323.                       ,(cond
  324.                     ((caddr v)    => (lambda (proc) `(,proc new-val)))
  325.                     (else        `(set! ,(car v) new-val)))))
  326.             vars-etc)
  327.            `((else (,delegate-set kw new-val))))))
  328.  
  329.     ,proc))
  330.  
  331.  
  332. ;;; let-configuration-getter-and-setter <vars-etc> proc
  333. ;;;
  334. ;;;   This procedure is like with-configuration-getter-and-setter (q.v.)
  335. ;;;   except that each element of <vars-etc> is:
  336. ;;;
  337. ;;;        (<var> initial-value getter-hook setter-hook)
  338. ;;;
  339. ;;;   Unlike with-configuration-getter-and-setter, let-configuration-getter-and-setter
  340. ;;;   introduces bindings for the variables named in <vars-etc>.
  341. ;;;   It is short-hand for:
  342. ;;;
  343. ;;;        (let ((<var1> initial-value-1)
  344. ;;;              (<var2> initial-value-2)
  345. ;;;            ...)
  346. ;;;          (with-configuration-getter-and-setter ((<var1> v1-get v1-set) ...) proc))
  347. ;;;
  348. (defmacro let-with-configuration-getter-and-setter (vars-etc proc)
  349.   `(let ,(map (lambda (v) `(,(car v) ,(cadr v))) vars-etc)
  350.      (with-configuration-getter-and-setter ,(map (lambda (v) `(,(car v) ,(caddr v) ,(cadddr v))) vars-etc)
  351.                        ,proc)))
  352.